home *** CD-ROM | disk | FTP | other *** search
/ MacWorld UK 2000 March / MW_UK_2000_03.iso / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / library.tcl < prev    next >
Encoding:
Text File  |  1999-12-05  |  36.9 KB  |  1,242 lines  |  [TEXT/ALFA]
  1. # init.tcl --
  2. #
  3. # Default system startup file for Tcl-based applications.  Defines
  4. # "unknown" procedure and auto-load facilities.
  5. #
  6. # SCCS: @(#) init.tcl 1.86 97/08/08 10:37:39
  7. #
  8. # Copyright (c) 1991-1993 The Regents of the University of California.
  9. # Copyright (c) 1994-1997 Sun Microsystems, Inc.
  10. # Some additions copyright (c) 1997-1998 Vince Darley.
  11.  
  12. set errorCode ""
  13. set errorInfo ""
  14.  
  15. if {[info commands tclLog] == ""} {
  16.     proc tclLog {string} {
  17.     message [string trim $string "\r"]
  18.     }
  19. }
  20. if {[info tclversion] >= 8.0} {
  21.     namespace eval index {}
  22.     namespace eval procs {}
  23.     # used to force some child namespaces into existence
  24.     ;proc namesp {var} {
  25.     if {[catch "uplevel global $var"]} {
  26.         set ns ""
  27.         while {[regexp "^(::)?($ns\[a-zA-Z_\]+::)" $var ns]} {
  28.         uplevel "namespace eval $ns {}"
  29.         }
  30.     }
  31.     }
  32. } else {
  33.     ;proc namesp {var} {}
  34.     rename load evaluate
  35. }
  36.  
  37. # 7.1 doesn't rename unbind in the actual application
  38. if {[info commands unBind] == ""} { rename unbind unBind }
  39.  
  40. # define compatibility procs for menu, bind, unbind
  41. if {[info commands bind] == ""} {
  42.     proc bind {args} { uplevel 1 Bind $args }
  43.     proc unbind {args} { uplevel 1 unBind $args }
  44.     proc menu {args} { 
  45.     regsub -all "\{menu " $args "\{Menu " args
  46.     uplevel 1 Menu $args 
  47.     }
  48. }
  49. namespace eval file {}
  50. # determine platform specific directory symbol
  51. regexp {Z(.)Z} [file join Z Z] "" file::separator
  52. # To get rid of the stupid {} variable created by the above line.
  53. # We 'catch' in case a future version of Tcl fixes this silliness.
  54. catch {unset {}}
  55.  
  56. ## 
  57.  # -------------------------------------------------------------------------
  58.  # 
  59.  # "unknown" --
  60.  # 
  61.  #  Almost the same as standard Tcl 8 unknown.  Since we're on a Mac,
  62.  #  I removed the auto_execok flag, and for some reason had to change
  63.  #  'history change $newcmd 0' to 'history change $newcmd'
  64.  # -------------------------------------------------------------------------
  65.  ##
  66. # unknown --
  67. # This procedure is called when a Tcl command is invoked that doesn't
  68. # exist in the interpreter.  It takes the following steps to make the
  69. # command available:
  70. #
  71. #    1. See if the autoload facility can locate the command in a
  72. #       Tcl script file.  If so, load it and execute it.
  73. #    2. If the command was invoked interactively at top-level:
  74. #        (a) see if the command exists as an executable UNIX program.
  75. #        If so, "exec" the command.
  76. #        (b) see if the command requests csh-like history substitution
  77. #        in one of the common forms !!, !<number>, or ^old^new.  If
  78. #        so, emulate csh's history substitution.
  79. #        (c) see if the command is a unique abbreviation for another
  80. #        command.  If so, invoke the command.
  81. #
  82. # Arguments:
  83. # args -    A list whose elements are the words of the original
  84. #        command, including the command name.
  85. proc unknown args {
  86.     global auto_noload env unknown_pending tcl_interactive
  87.     global errorCode errorInfo
  88.     
  89.     # Save the values of errorCode and errorInfo variables, since they
  90.     # may get modified if caught errors occur below.  The variables will
  91.     # be restored just before re-executing the missing command.
  92.     
  93.     set savedErrorCode $errorCode
  94.     set savedErrorInfo $errorInfo
  95.     set name [lindex $args 0]
  96.     if {![info exists auto_noload]} {
  97.     #
  98.     # Make sure we're not trying to load the same proc twice.
  99.     #
  100.     if {[info exists unknown_pending($name)]} {
  101.         return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
  102.     }
  103.     set unknown_pending($name) pending;
  104.     set ret [catch {auto_load $name} msg]
  105.     unset unknown_pending($name);
  106.     if {$ret != 0} {
  107.         return -code $ret -errorcode $errorCode \
  108.           "error while autoloading \"$name\": $msg"
  109.     }
  110.     if {![array size unknown_pending]} {
  111.         unset unknown_pending
  112.     }
  113.     if {$msg} {
  114.         set errorCode $savedErrorCode
  115.         set errorInfo $savedErrorInfo
  116.         set code [catch {uplevel 1 $args} msg]
  117.         if {$code ==  1} {
  118.         #
  119.         # Strip the last five lines off the error stack (they're
  120.         # from the "uplevel" command).
  121.         #
  122.         
  123.         set new [split $errorInfo \n]
  124.         set new [join [lrange $new 0 [expr {[llength $new] - 6}]] \n]
  125.         return -code error -errorcode $errorCode \
  126.           -errorinfo $new $msg
  127.         } else {
  128.         return -code $code $msg
  129.         }
  130.     }
  131.     }
  132.     if {([info level] == 1) && ([info script] == "") \
  133.       && [info exists tcl_interactive] && $tcl_interactive} {
  134.     set errorCode $savedErrorCode
  135.     set errorInfo $savedErrorInfo
  136.     if {$name == "!!"} {
  137.         set newcmd [history event]
  138.     } elseif {[regexp {^!(.+)$} $name dummy event]} {
  139.         set newcmd [history event $event]
  140.     } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new]} {
  141.         set newcmd [history event -1]
  142.         catch {regsub -all -- $old $newcmd $new newcmd}
  143.     }
  144.     if {[info exists newcmd]} {
  145.         tclLog "\r$newcmd"
  146.         history change $newcmd
  147.         return [uplevel $newcmd]
  148.     }
  149.     
  150.     set ret [catch {set cmds [info commands $name*]} msg]
  151.     if {[string compare $name "::"] == 0} {
  152.         set name ""
  153.     }
  154.     if {$ret != 0} {
  155.         return -code $ret -errorcode $errorCode \
  156.           "error in unknown while checking if \"$name\" is a unique command abbreviation: $msg"
  157.     }
  158.     if {[llength $cmds] == 1} {
  159.         return [uplevel [lreplace $args 0 0 $cmds]]
  160.     }
  161.     if {[llength $cmds] != 0} {
  162.         if {$name == ""} {
  163.         return -code error "empty command name \"\""
  164.         } else {
  165.         return -code error \
  166.           "ambiguous command name \"$name\": [lsort $cmds]"
  167.         }
  168.     }
  169.     }
  170.     return -code error "invalid command name \"$name\""
  171. }
  172.  
  173. ## 
  174.  # -------------------------------------------------------------------------
  175.  # 
  176.  # "auto_load" --
  177.  # 
  178.  #  I use this separate proc to be closer to the standard Tcl 8 system
  179.  #  of unknown-loading.
  180.  # -------------------------------------------------------------------------
  181.  ##
  182. proc auto_load cmd {
  183.     set f [procs::find $cmd]
  184.     if {$f != ""} {
  185.     uplevel \#0 source [list $f]
  186.     return [expr {[llength [info commands $cmd]] != 0}]
  187.     }
  188.     if {[regsub {^::} $cmd "" cmd]} {
  189.     set f [procs::find $cmd]
  190.     if {$f != ""} {
  191.         uplevel \#0 source [list $f]
  192.         return [expr {[llength [info commands $cmd]] != 0}]
  193.     }
  194.     }
  195.     # to cope with some Tcl 8 package stuff
  196.     if {[info tclversion] < 8.0} {
  197.     return 0
  198.     }
  199.     global auto_index auto_oldpath auto_path
  200.  
  201.     set namespace [uplevel {namespace current}]
  202.     set nameList [auto_qualify $cmd $namespace]
  203.     # workaround non canonical auto_index entries that might be around
  204.     # from older auto_mkindex versions
  205.     lappend nameList $cmd
  206.     foreach name $nameList {
  207.     if {[info exists auto_index($name)]} {
  208.         uplevel #0 $auto_index($name)
  209.         return [expr {[info commands $name] != ""}]
  210.     }
  211.     }
  212.     if {![info exists auto_path]} {
  213.     return 0
  214.     }
  215.  
  216.     if {![auto_load_index]} {
  217.     return 0
  218.     }
  219.  
  220.     foreach name $nameList {
  221.     if {[info exists auto_index($name)]} {
  222.         uplevel #0 $auto_index($name)
  223.         if {[info commands $name] != ""} {
  224.         return 1
  225.         }
  226.     }
  227.     }
  228.     return 0
  229. }
  230.  
  231. # auto_load_index --
  232. # Loads the contents of tclIndex files on the auto_path directory
  233. # list.  This is usually invoked within auto_load to load the index
  234. # of available commands.  Returns 1 if the index is loaded, and 0 if
  235. # the index is already loaded and up to date.
  236. #
  237. # Arguments: 
  238. # None.
  239.  
  240. proc auto_load_index {} {
  241.     global auto_index auto_oldpath auto_path errorInfo errorCode
  242.  
  243.     if {[info exists auto_oldpath]} {
  244.     if {$auto_oldpath == $auto_path} {
  245.         return 0
  246.     }
  247.     }
  248.     set auto_oldpath $auto_path
  249.  
  250.     # Check if we are a safe interpreter. In that case, we support only
  251.     # newer format tclIndex files.
  252.  
  253.     set issafe [interp issafe]
  254.     for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} {
  255.     set dir [lindex $auto_path $i]
  256.     set f ""
  257.     if {$issafe} {
  258.         catch {source [file join $dir tclIndex]}
  259.     } elseif {[catch {set f [open [file join $dir tclIndex]]}]} {
  260.         continue
  261.     } else {
  262.         set error [catch {
  263.         set id [gets $f]
  264.         if {$id == "# Tcl autoload index file, version 2.0"} {
  265.             eval [read $f]
  266.         } elseif {$id == \
  267.             "# Tcl autoload index file: each line identifies a Tcl"} {
  268.             while {[gets $f line] >= 0} {
  269.             if {([string index $line 0] == "#")
  270.                 || ([llength $line] != 2)} {
  271.                 continue
  272.             }
  273.             set name [lindex $line 0]
  274.             set auto_index($name) \
  275.                 "source [file join $dir [lindex $line 1]]"
  276.             }
  277.         } else {
  278.             error \
  279.               "[file join $dir tclIndex] isn't a proper Tcl index file"
  280.         }
  281.         } msg]
  282.         if {$f != ""} {
  283.         close $f
  284.         }
  285.         if {$error} {
  286.         error $msg $errorInfo $errorCode
  287.         }
  288.     }
  289.     }
  290.     return 1
  291. }
  292.  
  293. # auto_qualify --
  294. #
  295. # Compute a fully qualified names list for use in the auto_index array.
  296. # For historical reasons, commands in the global namespace do not have leading
  297. # :: in the index key. The list has two elements when the command name is
  298. # relative (no leading ::) and the namespace is not the global one. Otherwise
  299. # only one name is returned (and searched in the auto_index).
  300. #
  301. # Arguments -
  302. # cmd        The command name. Can be any name accepted for command
  303. #               invocations (Like "foo::::bar").
  304. # namespace    The namespace where the command is being used - must be
  305. #               a canonical namespace as returned by [namespace current]
  306. #               for instance.
  307.  
  308. proc auto_qualify {cmd namespace} {
  309.  
  310.     # count separators and clean them up
  311.     # (making sure that foo:::::bar will be treated as foo::bar)
  312.     set n [regsub -all {::+} $cmd :: cmd]
  313.  
  314.     # Ignore namespace if the name starts with ::
  315.     # Handle special case of only leading ::
  316.  
  317.     # Before each return case we give an example of which category it is
  318.     # with the following form :
  319.     # ( inputCmd, inputNameSpace) -> output
  320.  
  321.     if {[regexp {^::(.*)$} $cmd x tail]} {
  322.     if {$n > 1} {
  323.         # ( ::foo::bar , * ) -> ::foo::bar
  324.         return [list $cmd]
  325.     } else {
  326.         # ( ::global , * ) -> global
  327.         return [list $tail]
  328.     }
  329.     }
  330.     
  331.     # Potentially returning 2 elements to try  :
  332.     # (if the current namespace is not the global one)
  333.  
  334.     if {$n == 0} {
  335.     if {[string compare $namespace ::] == 0} {
  336.         # ( nocolons , :: ) -> nocolons
  337.         return [list $cmd]
  338.     } else {
  339.         # ( nocolons , ::sub ) -> ::sub::nocolons nocolons
  340.         return [list ${namespace}::$cmd $cmd]
  341.     }
  342.     } else {
  343.     if {[string compare $namespace ::] == 0} {
  344.         #  ( foo::bar , :: ) -> ::foo::bar
  345.         return [list ::$cmd]
  346.     } else {
  347.         # ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar
  348.         return [list ${namespace}::$cmd ::$cmd]
  349.     }
  350.     }
  351. }
  352.  
  353. # auto_mkindex:
  354. # Regenerate a tclIndex file from Tcl source files.  Takes two arguments:
  355. # the name of the directory in which the tclIndex file is to be placed,
  356. # and a glob pattern to use in that directory to locate all of the relevant
  357. # files.
  358. proc auto_mkindex {dir {files *.tcl}} {
  359.     # Due to some peculiarities with current working directories
  360.     # under some MacOS/HFS+/other conditions, we avoid using
  361.     # 'cd' and 'pwd' explicitly if possible.
  362.     set dir [file nativename $dir]
  363.     global tcl_platform
  364.     switch -- $tcl_platform(platform) {
  365.     "macintosh" {
  366.         if {$dir == ":" || $dir == "."} {
  367.         set dir [pwd]
  368.         }
  369.     }
  370.     default {
  371.         if {$dir == "."} {
  372.         set dir [pwd]
  373.         }
  374.     }
  375.     }
  376.     set relative 1
  377.     foreach volume [file volumes] {
  378.     if {[string first $volume $dir] == 0} {
  379.         unset relative
  380.         break
  381.     }
  382.     }
  383.     if {[info exists relative]} {
  384.     set dir [file join [pwd] $dir]
  385.     unset relative
  386.     }
  387.     # So we can handle relative path names
  388.     if {[file pathtype $dir] == "relative"} {
  389.     set dir [file join [pwd] $dir]
  390.     }
  391.     if {![catch {file readlink $dir} _root]} {
  392.     set dir $_root
  393.     }
  394.     set dir [string trim $dir :]
  395.     append line "# Tcl autoload index file: each line\
  396.       identifies a file (nowrap)\n\n"
  397.     set indexvar "[file tail [string trim $dir :]]_index"
  398.     append line "set \"${indexvar}\" \{\n"
  399.     
  400.     set cid [scancontext create]
  401.     # This pattern is used to extract procedures when the 'scanfile'
  402.     # command is used below.  We don't do anything too dramatic if
  403.     # the procedure name can't be extracted.  The most likely cause
  404.     # is a garbled file.
  405.     scanmatch $cid "^\[ \t\]*proc\[ \t\]" {
  406.     if {[regexp "^\[ \t\]*proc\[ \t\]+((\"\[^\"\]+\")|(\{\[^\}\]+\})|(\[^ \t\]*))" \
  407.       $matchInfo(line) match procName]} {
  408.         append line "$procName "
  409.     } else {
  410.         message "Couldn't extract a proc from '$matchInfo(line)'!"
  411.     }
  412.     }
  413.     foreach file [glob -dir $dir -- $files] {
  414.     watchCursor
  415.     set f ""
  416.     append line "\{[file tail $file]\14 "
  417.     message [file tail $file]
  418.     if {[catch {open $file r} fid]} {
  419.         lappend errors $fid
  420.         lappend errorFiles $file
  421.     } else {
  422.         if {[catch {scanfile $cid $fid} err]} {
  423.         lappend errors $err
  424.         lappend errorFiles $file
  425.         }
  426.         close $fid
  427.     }
  428.     append line "\}\n"
  429.     }
  430.     
  431.     scancontext delete $cid
  432.     
  433.     append line "\}\n"
  434.     if {[info exists errors]} {
  435.     if {[dialog::yesno -y "View the error" -n "Continue" \
  436.       "The following files: [join $errorFiles ,] were unable\
  437.       to be opened or scanned for procedures to store in Tcl index\
  438.       files.  This is a serious error.  Alpha will not be\
  439.       able to find procedures stored in those files, and will\
  440.       therefore fail to function correctly.  You should\
  441.       ascertain the cause of these\
  442.       problems and fix them.  Your disk may be damaged.\r\
  443.       To avoid some of these problems, the Tcl index file\
  444.       in $dir will not be replaced."]} {
  445.         dialog::alert [join $errors "\r"]
  446.     }
  447.     } else {
  448.     if {[catch {open [file join $dir tclIndexx] w} fid]} {
  449.         if {[file exists [file join $dir tclIndex]] \
  450.           && ![file writable $dir]} {
  451.         # This is a read-only directory, so there isn't
  452.         # a problem that we couldn't write to it.  Probably
  453.         # it's a system directory such as the base Tcl library.
  454.         message "'$dir' is read-only, so I'll use the existing Tcl index."
  455.         } else {
  456.         dialog::alert "The Tcl index file in $dir could not\
  457.           be rewritten.  Perhaps the file is locked or read-only?\
  458.           The old index will be left intact, but you should fix\
  459.           this problem so Alpha can index new files in\
  460.           this directory."
  461.         }
  462.     } else {
  463.         if {[catch {puts -nonewline $fid $line} err]} {
  464.         if {[dialog::yesno -y "View the error" -n "Continue" \
  465.           "The Tcl index file in $dir was successfully opened,\
  466.           but Alpha encountered an error while writing to the\
  467.           file.  This is a very serious problem, and Alpha will\
  468.           probably no longer function correctly.  At the very\
  469.           least you will need to reinstall that directory, and\
  470.           perhaps all of Alpha."]} {
  471.             dialog::alert $err
  472.         }
  473.         }
  474.         catch {close $fid}
  475.     }
  476.     foreach i [info vars $indexvar] {
  477.         global $i
  478.         unset $i
  479.     }
  480.     }
  481.     
  482. }
  483.  
  484. proc procs::find {cmd} {
  485.     global auto_path
  486.     regsub -all {[][\$?^|*+()\{\}]} $cmd {\\&} cmd
  487.     foreach path $auto_path {
  488.     if {![file exists $path]} continue
  489.     if {[info tclversion] < 8.0} {
  490.         if {![catch {file readlink $path} _path]} {
  491.         set path $_path
  492.         }
  493.     } else {
  494.         if {[file type $path] == "link"} {
  495.         if {[catch {set path [file readlink $path]}]} {
  496.             # forget about this one
  497.             continue
  498.         }
  499.         }
  500.     }
  501.     set index "[file tail $path]_index"
  502.     global $index
  503.     if {![info exists $index]} {
  504.         if {![file exists [file join $path tclIndexx]]} continue
  505.         uplevel \#0 source [list [file join $path tclIndexx]]
  506.         if {![info exists $index]} {
  507.         alertnote "Tcl index in $path is incorrectly formed.  It\
  508.           should set the variable $index but doesn't.  You should\
  509.           fix this problem."
  510.         }
  511.     }
  512.     if {[regexp "\n\{(\[^\14\]+)\14\[^\n\]* \[\"\{\]?(::)?${cmd}\[\"\}\]? " [set $index] dummy file]} {
  513.         return [file join $path $file]
  514.     }
  515.     }
  516.     return ""
  517. }
  518. # this proc adds 'dummy' so 'file dirname' works the same
  519. # way for tcl7.4 and tcl8.0.
  520. proc alpha::makeAutoPath {{check_dups 1} {skipPrefs 0}} {
  521.     global HOME auto_path
  522.     if {$check_dups} {
  523.     set lcmd lunion
  524.     } else {
  525.     set lcmd lappend
  526.     }
  527.     set root [file join $HOME Tcl]
  528.     if {![catch {file readlink $root} _root]} {
  529.     set root $_root
  530.     }
  531.     
  532.     foreach dir {SystemCode Modes Menus} {
  533.     $lcmd auto_path [file join $root $dir]
  534.     foreach d [glob -t d -nocomplain -dir [file join $root $dir] *] {
  535.         $lcmd auto_path [file dirname "${d}dummy"]
  536.     }
  537.     }
  538.     if {!$skipPrefs} {
  539.     $lcmd auto_path [file join $root Packages]
  540.     $lcmd auto_path [file join $root UserModifications]
  541.     foreach d [glob -t d -nocomplain -dir [file join $root Packages] *] {
  542.         $lcmd auto_path [file dirname "${d}dummy"]
  543.     }
  544.     }
  545. }
  546.  
  547. # Clean up temporary files:
  548. proc removeTemporaryFiles {} {
  549.     global PREFS
  550.     if {[file exists [file join $PREFS tmp]]} {
  551.     foreach f [glob -dir [file join $PREFS tmp] -nocomplain *] {
  552.         message "removing [file tail $f]…"
  553.         file delete $f
  554.     }
  555.     }
  556.     message "all temporary files removed"
  557. }
  558. ## 
  559.  # -------------------------------------------------------------------------
  560.  # 
  561.  # "auto_reset" --
  562.  # 
  563.  #  After rebuilding indices, Tcl retains its old index information unless
  564.  #  we tell it not to.
  565.  # -------------------------------------------------------------------------
  566.  ##
  567. proc auto_reset {} {
  568.     global auto_path
  569.     foreach path $auto_path {
  570.     if {![file exists $path]} continue
  571.     set index "[file tail $path]_index"
  572.     global $index
  573.     catch {unset $index}
  574.     }
  575. }
  576.  
  577. #================================================================================
  578. # Wonderful procs from Vince Darley (vince@santafe.edu).
  579. #===============================================================================
  580.  
  581. if {[info tclversion] < 8.0} {
  582. proc traceTclProc {{func ""}} {
  583.     global tclMenu
  584.     if {[llength [traceFunc status]]>2} {
  585.     catch {markMenuItem $tclMenu {traceTclProc…} off}
  586.     catch {enableMenuItem $tclMenu dumpTraces off}
  587.     if {[string length [set data [traceDump]]]} {
  588.         if {[dialog::yesno "Dump traces?"]} {
  589.         dumpTraces [string trimright [lindex [traceFunc status] 3] {,}] $data
  590.         }
  591.     }
  592.     traceFunc off
  593.     message "Tracing off."
  594.     return
  595.     }
  596.     if {$func == ""} {
  597.     set func [procs::pick 1]
  598.     }
  599.     if {![string length $func]} return
  600.     traceFunc on $func ""
  601.     catch {markMenuItem $tclMenu {traceTclProc…} on}
  602.     catch {enableMenuItem $tclMenu dumpTraces on}
  603.     message "Tracing '$func'…"
  604. }
  605.  
  606.  
  607. proc dumpTraces {{name ""} {data ""}} {
  608.     if {![string length $name]} {
  609.     set name [string trimright [lindex [traceFunc status] 3] {,}]
  610.     }
  611.     if {![string length $data]} {
  612.     set data [traceDump]
  613.     }
  614.     
  615.     if {![string length $data]} {
  616.     message "Trace buffer empty"
  617.     } else {
  618.     new -n "* Trace '$name' *" -m Tcl -info $data
  619.     }
  620. }
  621.  
  622. proc procs::traceProc {func} {
  623.     global tclMenu
  624.     # if we're tracing already then clear it
  625.     if {[llength [traceFunc status]]>2} { traceTclProc }
  626.     traceFunc on $func ""
  627.     catch {markMenuItem $tclMenu {traceTclProc…} on}
  628.     catch {enableMenuItem $tclMenu dumpTraces on}
  629.     message "Tracing '$func'…"
  630. }
  631.  
  632. proc procs::pick {{try_sel 0}} {
  633.     if {$try_sel && [llength [winNames]] && [string length [set sel [getSelect]]]} {
  634.     if {[info procs $sel] == "$sel"} {
  635.         return $sel
  636.     } else {
  637.         return [listpick -L $sel -p {Func Name:} [lsort -ignore [info procs]]]
  638.     }
  639.     } else {
  640.     return [listpick -p {Func Name:} [lsort -ignore [info procs]]]
  641.     }
  642. }
  643.  
  644. } else {
  645. proc procs::traceProc {func} {
  646.     uplevel traceTclProc $func
  647. }
  648.  
  649. ## 
  650.  # -------------------------------------------------------------------------
  651.  # 
  652.  # "procs::pick" --
  653.  # 
  654.  # -------------------------------------------------------------------------
  655.  ##
  656. proc procs::pick {{try_sel 0}} {
  657.     if {$try_sel && [llength [winNames]] && [string length [set sel [getSelect]]]} {
  658.     if {[llength [uplevel \#0 [list info commands $sel]]] && ![catch {info args $sel}]} {
  659.         return $sel
  660.     } 
  661.     } else {
  662.     set sel ""
  663.     }
  664.     set ns ::
  665.     while {1} {
  666.     set procs [lsort -ignore [namespace children $ns]]
  667.     eval lappend procs [lsort -ignore [uplevel \#0 namespace eval $ns [list info procs]]]
  668.     set choice [listpick -L $sel -p "Pick a function or child namespace in '$ns'" $procs]
  669.     if {![regexp {^::} $choice]} {
  670.         if {${ns} == "::"} {
  671.         return "::${choice}"
  672.         } else {
  673.         return "${ns}::${choice}"
  674.         }
  675.     }
  676.     set ns $choice
  677.     }
  678. }
  679.  
  680. if {![catch {package require Trace}]} {
  681.     proc traceTclProc {{func ""}} {
  682.     global tclMenu 
  683.     set cmd [lindex [tracecommand list] 0]
  684.     if {$cmd != ""} {
  685.         catch {markMenuItem $tclMenu {traceTclProcÉ} off}
  686.         catch {enableMenuItem $tclMenu dumpTraces off}
  687.         dumpTraces $cmd [tracecommand dump $cmd] 1
  688.         tracecommand off $cmd
  689.         message "Tracing off."
  690.         if {$func == ""} {return}
  691.     }
  692.     if {$func == ""} {
  693.         set func [procs::pick 1]
  694.     }
  695.     if {![string length $func]} return
  696.     tracecommand on $func
  697.     catch {markMenuItem $tclMenu {traceTclProcÉ} on}
  698.     catch {enableMenuItem $tclMenu dumpTraces on}
  699.     message "Tracing '$func'É"
  700.     }
  701.     proc dumpTraces {{name ""} {data ""} {ask 0}} {
  702.     if {![string length $name]} {
  703.         set name [lindex [tracecommand list] 0]
  704.     }
  705.     if {![string length $data]} {
  706.         set data [tracecommand dump $name]
  707.     }
  708.     
  709.     if {![string length $data]} {
  710.         message "Trace buffer empty"
  711.     } else {
  712.         if {$ask} {
  713.         if {![dialog::yesno "Dump traces?"]} {return}
  714.         }
  715.         new -n "* Trace '$name' *" -m Tcl -text $data -shell 1 -read-only 1
  716.     }
  717.     }
  718. } else {
  719.  
  720.  
  721. ## 
  722.  # -------------------------------------------------------------------------
  723.  # 
  724.  # "traceTclProc" --
  725.  # 
  726.  #  Trace and dump still need a little work under Alpha 8.0.  Notice that
  727.  #  traces are stored in a file, not in memory as in previous versions
  728.  #  of Alpha.
  729.  # -------------------------------------------------------------------------
  730.  ##
  731. proc traceTclProc {{func ""}} {
  732.     global tclMenu alpha::tracingProc alpha::tracingChannel PREFS
  733.     if {[cmdtrace depth] > 0} {
  734.     catch {markMenuItem $tclMenu {traceTclProc…} off}
  735.     catch {enableMenuItem $tclMenu dumpTraces off}
  736.     catch {
  737.         cmdtrace off
  738.         close $alpha::tracingChannel
  739.         set alpha::tracingChannel ""
  740.     }
  741.     if {[file exists [file join $PREFS tmp traceDump]]} {
  742.         dumpTraces "" "" 1
  743.         file delete [file join $PREFS tmp traceDump]
  744.     }
  745.     message "Tracing off."
  746.     if {$func == ""} {return}
  747.     }
  748.     if {$func == ""} {
  749.     set func [procs::pick 1]
  750.     }
  751.     if {![string length $func]} return
  752.     if {![file exists [file join $PREFS tmp]]} {
  753.     file mkdir [file join $PREFS tmp]
  754.     }
  755.     set alpha::tracingChannel [open [file join $PREFS tmp traceDump] w]
  756.     cmdtrace on $alpha::tracingChannel inside $func
  757.     set alpha::tracingProc $func
  758.     catch {markMenuItem $tclMenu {traceTclProc…} on}
  759.     catch {enableMenuItem $tclMenu dumpTraces on}
  760.     message "Tracing '$func'…"
  761. }
  762.  
  763.  
  764. proc dumpTraces {{name ""} {data ""} {ask 0}} {
  765.     global alpha::tracingProc alpha::tracingChannel PREFS
  766.     if {![string length $name]} {
  767.     set name $alpha::tracingProc
  768.     }
  769.     if {![string length $data]} {
  770.     set data [file::readAll [file join $PREFS tmp traceDump]]
  771.     if {$alpha::tracingChannel != ""} {
  772.         close $alpha::tracingChannel
  773.         file delete [file join $PREFS tmp traceDump]
  774.         set alpha::tracingChannel [open [file join $PREFS tmp traceDump] w]
  775.         cmdtrace configure $alpha::tracingChannel
  776.     }
  777.     }
  778.     
  779.     if {![string length $data]} {
  780.     message "Trace buffer empty"
  781.     } else {
  782.     if {$ask} {
  783.         if {![dialog::yesno "Dump traces?"]} {return}
  784.     }
  785.     new -n "* Trace '$name' *" -m Tcl -text $data -shell 1 -read-only 1
  786.     }
  787. }
  788.  
  789. }
  790. }
  791.  
  792.  
  793. proc rebuildTclIndices {} {
  794.     global auto_path
  795.     foreach dir $auto_path {
  796.     # if directory exists
  797.     if {[file isdir $dir]} {
  798.         # if there are any files
  799.         if {![catch {glob -dir $dir *.*tcl} err]} {
  800.         message "Building [file tail $dir] index…"                
  801.         # use 'catch' also in case directory is write-protected
  802.         if {[catch {auto_mkindex $dir *.*tcl} err]} {
  803.             message "Problem rebuilding directory $dir : $err"
  804.         }
  805.         } else {
  806.         message "Directory '$dir' contains no Tcl files!"
  807.         }
  808.     } else {
  809.         message "Directory '$dir' doesn't appear to exist."
  810.     }
  811.     }
  812.     message ""
  813.     # make alpha forget its old information so the new stuff is loaded
  814.     # when required.
  815.     catch {auto_reset}
  816. }
  817.  
  818. set alpha::rebuilding 0
  819.  
  820. proc alpha::rebuildPackageIndices {} {
  821.     alpha::makeIndices
  822.     message "Indices and package menu rebuilt."
  823. }
  824.  
  825. proc alpha::makeIndices {} {
  826.     # add all new directories to the auto_path
  827.     alpha::makeAutoPath
  828.     # ensure count is correctly set - otherwise we'd probably have to
  829.     # rebuild next time we started up.
  830.     alpha::rectifyPackageCount
  831.     set types {index::feature index::mode index::uninstall  index::maintainer index::help index::disable}
  832.     global pkg_file HOME alpha::rebuilding alpha::version file::separator \
  833.       index::oldmode alpha::tclversion
  834.     eval global $types
  835.     # store old mode information so we can check what changed
  836.     catch {cache::readContents index::mode}
  837.     catch {array set index::oldmode [array get index::mode]}
  838.     
  839.     catch {eval cache::delete $types}
  840.     foreach type $types {
  841.     catch {unset $type}
  842.     }
  843.     foreach dir [list SystemCode Modes Menus Packages] {
  844.     lappend dirs "[file join ${HOME} Tcl ${dir}]${file::separator}"
  845.     eval lappend dirs [glob -t d -dir [file join ${HOME} Tcl ${dir}] -nocomplain *]
  846.     }
  847.     if {[file exists [file join ${HOME} AlphaCore]]} {
  848.     lappend dirs "[file join ${HOME} AlphaCore]${file::separator}"
  849.     }
  850.     set alpha::rebuilding 1
  851.     # provide the 'Alpha' and 'AlphaTcl' packages
  852.     ;alpha::extension Alpha ${alpha::version} {} help {file "Alpha Manual"}
  853.     ;alpha::extension AlphaTcl ${alpha::tclversion} {} help {file "Extending Alpha"}
  854.     # declare 2 different scan contexts:
  855.     set cid_scan [scancontext create]
  856.     scanmatch $cid_scan  "^\[ \t\]*alpha::(menu|mode|flag|extension|feature|package\[ \t\]+(uninstall|disable|maintainer|help))\[ \t\\\\\]" {
  857.     incr rebuild_cmd_count 1
  858.     }
  859.     scanmatch $cid_scan "^\[ \t\]*newPref\[ \t\]" {
  860.     if {[incr numprefs] == 1} {
  861.         set newpref_start $matchInfo(offset)
  862.     }
  863.     }
  864.     set cid_help [scancontext create]
  865.     scanmatch $cid_help "^\[ \t\]*#" {
  866.     if {[expr {$linenum +1}] != $matchInfo(linenum)} { set hhelp "" }
  867.     append hhelp [string trimleft $matchInfo(line) " \t#"] " "
  868.     set linenum $matchInfo(linenum)
  869.     }
  870.     scanmatch $cid_help "^\[ \t\]*newPref\[ \t\]" {
  871.     if {[expr {$linenum +1}] == $matchInfo(linenum)} {
  872.         if {$hhelp != ""} {
  873.         set pkg [lindex $matchInfo(line) 4]
  874.         # allow comment to over-ride the mode/package
  875.         regexp "^\\((\\w+)\\)\[ \t\]*(.*)\$" $hhelp "" pkg hhelp
  876.         if {$pkg == "" || $pkg == "global"} {
  877.             set prefshelp([lindex $matchInfo(line) 2]) $hhelp
  878.         } else {
  879.             set prefshelp($pkg,[lindex $matchInfo(line) 2]) $hhelp
  880.         }
  881.         }
  882.     }
  883.     set hhelp ""
  884.     if {[incr numprefs -1] == 0} {
  885.         error "done"
  886.     }
  887.     }
  888.     
  889.     global rebuild_cmd_count
  890.     foreach d $dirs {
  891.     foreach f [glob -nocomplain -path $d *.tcl] {
  892.         if {![catch {open $f} fid]} {
  893.         message "scanning [file tail $f]…"
  894.         set numprefs 0
  895.         set rebuild_cmd_count 0
  896.         # check for 'newPref' or 'alpha::package' statements
  897.         scanfile $cid_scan $fid
  898.         if {$numprefs > 0} {
  899.             message "scanning [file tail $f]…($numprefs prefs)"
  900.             incr newpref_start -520
  901.             seek $fid [expr {$newpref_start > 0 ? $newpref_start : 0}]
  902.             set linenum -2
  903.             set hhelp ""
  904.             catch [list scanfile $cid_help $fid]
  905.         }
  906.         close $fid
  907.         if {$rebuild_cmd_count > 0} {
  908.             message "scanning [file tail $f] for packages"
  909.             set pkg_file $f
  910.             if {[catch {uplevel \#0 [list source $f]} res] != 11} {
  911.             if {[askyesno "Had a problem extracting package information from [file tail $f].  View error?"] == "yes"} {
  912.                 alertnote [string range $res 0 240]
  913.             }
  914.             }
  915.         }
  916.         }
  917.     }
  918.     }
  919.     catch {unset rebuild_cmd_count}
  920.     set alpha::rebuilding 0
  921.     
  922.     scancontext delete $cid_scan
  923.     scancontext delete $cid_help
  924.     cache::create index::prefshelp variable prefshelp
  925.     
  926.     foreach type $types {
  927.     cache::add $type "variable" $type
  928.     if {$type != "index::feature"} { catch {unset $type} }
  929.     }
  930.     catch {unset index::oldmode}
  931.     catch {unset pkg_file}
  932.     #foreach n [array names index::feature] {}
  933.     global alpha::requirements
  934.     if {[info exists alpha::requirements]} {
  935.     foreach itm ${alpha::requirements} {
  936.         set m [lindex $itm 0]
  937.         set req [lindex $itm 1]
  938.         if {[catch {package::versionCheck [lindex $req 0] [lindex $req 2]} err]} {
  939.         alertnote "$m mode requirements failure: $err  You should upgrade that package."
  940.         }
  941.     }
  942.     }
  943.     
  944.     message "Package index rebuilt."
  945. }
  946.  
  947. # 'exit' kills Alpha without allowing it to save etc.
  948. # 'quit' is therefore more mac-like
  949. rename exit ""
  950. proc exit {} {quit}
  951.  
  952. proc alpha::reportError {string} {
  953.     global reportErrors
  954.     if {$reportErrors} {
  955.     alertnote [string range $string 0 200]
  956.     } else {
  957.     global alpha::errorLog
  958.     append alpha::errorLog $string
  959.     }
  960. }
  961.  
  962. proc userMessage {{alerts 1} {message ""}} {
  963.     if {$alerts} {
  964.     alertnote $message
  965.     } else {
  966.     message $message
  967.     }
  968. }
  969.  
  970. namespace eval flag {}
  971.  
  972. # Always use this proc, don't mess with 'flag::types' directly.
  973. proc flag::addType {type} {
  974.     global flag::types
  975.     if {[lsearch -exact ${flag::types} $type] == -1} {
  976.     lappend flag::types $type
  977.     }
  978. }
  979.  
  980. # Declare basic preference types
  981. namespace eval flag {}
  982. set flag::types [list "flag" "variable" "binding" "menubinding" \
  983.   "file" "io-file" "funnyChars"]
  984. # Note: other types are triggered by vars ending in 'Colour', 'Color',
  985. # 'Folder', 'Path', 'Mode', 'Sig', or 'SearchPath'
  986.  
  987. namespace eval global {}
  988.  
  989. ## 
  990.  # -------------------------------------------------------------------------
  991.  # 
  992.  # "newPref" --
  993.  # 
  994.  #  Define a new preference variable/flag.  You can call this procedure
  995.  #  either with multiple arguments or with a single list of all the
  996.  #  arguments.  So 'newPref flag Hey ...' or 'newPref {flag Hey ...}'
  997.  #  are both fine.
  998.  #  
  999.  #  'type' is one of:
  1000.  #    'flag' (on/off only), 'variable' (anything), 'binding' (key-combo)
  1001.  #    'menubinding' (key-combo which works in a menu), 'file' (input only),
  1002.  #    'io-file' (either input or output).  Variables whose name ends in
  1003.  #    Sig, Folder, Path, Mode, Colour, Color or SearchPath (case matters here) 
  1004.  #    are treated differently, but are still considered of type 'variable'.
  1005.  #    For convenience this proc will map types sig, folder, color, ...
  1006.  #    into 'variable' for you, _if_ the variable ends with the correct
  1007.  #    string.
  1008.  #    
  1009.  #  'name' is the var name, 
  1010.  #  
  1011.  #  'val' is its default value (which will be ignored if the variable
  1012.  #  already has a value)
  1013.  #  
  1014.  #  'pkg' is either 'global' to mean a global preference, or the name 
  1015.  #  of the mode or package (no spaces) for which this is a preference.
  1016.  #  
  1017.  #  'pname' is a procedure to call if this preference is changed by
  1018.  #  the user (no need to setup a trace).  This proc is only called
  1019.  #  for changes made through prefs dialogs or prefs menus created by
  1020.  #  Alpha's core procs.  Other changes are not traced.
  1021.  #  
  1022.  #  Depending on the previous values, there are two optional arguments
  1023.  #  with the following uses:
  1024.  #  
  1025.  #  TYPE:
  1026.  #  
  1027.  #  variable:
  1028.  #  
  1029.  #  'options' is a list of items from which this preference takes a single
  1030.  #  item.
  1031.  #  'subopt' is any of 'item', 'index', 'varitem' or 'varindex' or 'array', where
  1032.  #  'item' indicates the pref is simply an item from the given list
  1033.  #  of items, 'index' indicates it is an index into that list, and
  1034.  #  'var*' indicates 'items' is in fact the name of a global variable
  1035.  #  which contains the list. 'array' means take one of the values from an array.
  1036.  #  If no value is given, 'item' is the default
  1037.  #  
  1038.  #  binding:
  1039.  #  
  1040.  #  'options' is the name of a proc to which this item should be bound.
  1041.  #  If options = '1', then we Bind to the proc with the same name as
  1042.  #  this variable.  Otherwise we do not perform automatic bindings.
  1043.  #  
  1044.  #  'subopt' indicates whether the binding is mode-specific or global.
  1045.  #  It should either be 'global' or the name of a mode.  If not given,
  1046.  #  it defaults to 'global' for all non-modes, and to mode-specific for
  1047.  #  all packages.  (Alpha tests if something is a mode by the existence
  1048.  #  of mode::features($mode))
  1049.  # -------------------------------------------------------------------------
  1050.  ##
  1051. proc newPref {vtype {name {}} {val 0} {pkg "global"} {pname ""} {options ""} {subopt ""}} {
  1052.     if {$name == {}} { uplevel 1 newPref $vtype}
  1053.     
  1054.     global allFlags allVars tclvars modeVars flag::procs \
  1055.       flag::type flag::types alpha::earlyPrefs
  1056.     # 'link' means link this variable with Alpha's internals.
  1057.     if {[regexp {^early(.*)$} $vtype "" vtype]} {
  1058.     lappend alpha::earlyPrefs $name
  1059.     }
  1060.     if {[regexp {^link(.*)$} $vtype "" vtype]} {
  1061.     linkVar $name
  1062.     # linked variables over-ride differently to normal preferences.
  1063.     if {$val != ""} { global $name ; set $name $val }
  1064.     }
  1065.     set bad 1
  1066.     foreach ty ${flag::types} {
  1067.     if {[string first $vtype $ty] == 0} {
  1068.         set vtype $ty
  1069.         set bad 0
  1070.         break
  1071.     }
  1072.     }
  1073.     if {$bad} {
  1074.     foreach ty {SearchPath Folder Path Mode Colour Color Sig} {
  1075.         if {[string first $vtype [string tolower $ty]] == 0} {
  1076.         if {[regexp -- "${ty}\$" $name]} {
  1077.             set vtype variable
  1078.             set bad 0
  1079.             break
  1080.         } else {
  1081.             error "Type '$vtype' requires the variable's name to end in '$ty'"
  1082.         }
  1083.         }
  1084.     }
  1085.     if {$bad} {error "Unknown type '$vtype' in call to newPref"}
  1086.     }
  1087.     if {$pkg == "global"} {
  1088.     switch -- $vtype {
  1089.         "flag" {
  1090.         lappend allFlags $name
  1091.         }
  1092.         "variable" {
  1093.         lappend allVars $name
  1094.         }
  1095.         default {
  1096.         set flag::type($name) $vtype
  1097.         lappend allVars $name
  1098.         }
  1099.     }
  1100.     
  1101.     global $name mode global::_varMem
  1102.     lunion tclvars $name
  1103.     if {[info exists mode] && $mode != ""} {
  1104.         global ${mode}modeVars
  1105.         if {[info exists $name] && [info exists ${mode}modeVars($name)]} {
  1106.         # Don't override an existing mode variable which has been
  1107.         # copied into the global namespace; instead just place
  1108.         # value in the global cache
  1109.         set global::_varMem($name) $val
  1110.         } else {
  1111.         if {![info exists $name]} {set $name $val} else { set val [set $name] }
  1112.         }
  1113.     } else {
  1114.         if {![info exists $name]} {set $name $val} else { set val [set $name] }
  1115.     }
  1116.     } else {
  1117.     global ${pkg}modeVars mode alpha::changingMode
  1118.     lunion modeVars $name
  1119.     
  1120.     if {![info exists ${pkg}modeVars($name)]} {
  1121.         set ${pkg}modeVars($name) $val
  1122.     } else {
  1123.         set val [set ${pkg}modeVars($name)]
  1124.     }
  1125.     if {!${alpha::changingMode} && ($mode == $pkg)} {
  1126.         global $name global::_varMem
  1127.         # Need to load up this global cache for when mode changes!
  1128.         if {[info exists $name]} { 
  1129.         set global::_varMem($name) [set $name]
  1130.         }
  1131.         set $name $val
  1132.     }
  1133.     switch -- $vtype {
  1134.         "flag" {
  1135.         if {[lsearch -exact $allFlags $name] == -1} {
  1136.             lappend allFlags $name
  1137.         }
  1138.         }
  1139.         "variable" {
  1140.         lappend allVars $name
  1141.         }
  1142.         default {
  1143.         set flag::type($name) $vtype
  1144.         lappend allVars $name
  1145.         }
  1146.     }
  1147.     }
  1148.     # handle 'options'
  1149.     if {$options != ""} {
  1150.     switch -- $vtype {
  1151.         "variable" {
  1152.         global flag::list
  1153.         if {$subopt == ""} { set subopt "item" }
  1154.         if {[lsearch -exact "array item index varitem varindex" $subopt] == -1} {
  1155.             error "Unknown list element type '$subopt' in call to newPref."
  1156.         }
  1157.         set flag::list($name) [list $subopt $options]
  1158.         }
  1159.         "binding" {
  1160.         global flag::binding mode::features
  1161.         if {[info exists mode::features($pkg)]} {
  1162.             if {$subopt == ""} { 
  1163.             set subopt $pkg
  1164.             } else {
  1165.             if {$subopt == "global"} { set subopt "" }
  1166.             }
  1167.         } 
  1168.         set flag::binding($name) [list $subopt $options]
  1169.         if {$options == 1} { set options $name }
  1170.         catch "Bind [keys::toBind $val] [list $options] $subopt"
  1171.         }
  1172.     }
  1173.     }
  1174.     # register the 'modify' proc
  1175.     if {[string length $pname]} {
  1176.     set flag::procs($name) $pname
  1177.     }
  1178. }
  1179.  
  1180. ## 
  1181.  # -------------------------------------------------------------------------
  1182.  # 
  1183.  # "alpha::rectifyPackageCount" --
  1184.  # 
  1185.  #  Returns 1 if count has changed
  1186.  # -------------------------------------------------------------------------
  1187.  ##
  1188. proc alpha::rectifyPackageCount {} {
  1189.     global HOME file::separator
  1190.     # check things haven't changed
  1191.     foreach d {Modes Menus Packages} {
  1192.     lappend count [llength [glob -nocomplain -dir [file join ${HOME} Tcl ${d}] "*\{.tcl,${file::separator}\}"]]
  1193.     }
  1194.     if {![cache::exists index::count[join $count -]]} {
  1195.     cache::deletePat index::count*
  1196.     cache::create index::count[join $count -]
  1197.     return 1
  1198.     } else {
  1199.     return 0
  1200.     }
  1201. }
  1202.  
  1203. proc alpha::checkConfiguration {} {
  1204.     global alpha::version alpha::tclversion
  1205.     if {![cache::exists index::feature] || (![cache::exists index::mode]) \
  1206.       || ([alpha::package versions Alpha] != ${alpha::version}) \
  1207.       || ([alpha::package versions AlphaTcl] != ${alpha::tclversion})} {
  1208.     set rebuild 1
  1209.     # If there's no package information stored at all, or if Alpha's
  1210.     # version number has changed, zap the cache.  This may not be
  1211.     # required, but is safer since core-code changes may modify the
  1212.     # form of the cache, or change the format of cached menus etc.
  1213.     global PREFS
  1214.     if {[cache::exists configuration]} {
  1215.         # in case we crashed or some other weirdness
  1216.         catch {file delete [file join ${PREFS} configuration]}
  1217.         # now backup the configuration file
  1218.         # Alpha has a bad filesystem bug which can sometimes arise
  1219.         # here, so we do this crazy stuff.
  1220.         if {[catch {file rename [file join ${PREFS} Cache configuration] \
  1221.           [file join ${PREFS} configuration]}]} {
  1222.         dialog::alert "You've hit an unfortunate filesystem bug in Alpha.\
  1223.           Unfortunately there is no workaround.  Alpha will now forget\
  1224.           your globally active features, and some other preferences.\r\
  1225.           Sorry!  This will be fixed in Alpha 8.0."
  1226.         }
  1227.         rm -r [file join ${PREFS} Cache]
  1228.         file mkdir [file join ${PREFS} Cache]
  1229.         catch {file rename [file join ${PREFS} configuration] \
  1230.           [file join ${PREFS} Cache configuration]}
  1231.     } else {
  1232.         rm -r [file join ${PREFS} Cache]
  1233.         file mkdir [file join ${PREFS} Cache]
  1234.     }
  1235.     } else {
  1236.     set rebuild [alpha::rectifyPackageCount]
  1237.     }
  1238.     return $rebuild
  1239. }
  1240.  
  1241.  
  1242.